home *** CD-ROM | disk | FTP | other *** search
( defmodule init (arith bci lists classes sockets streams ccc symbols strings calls others tables vectors (except (error cerror) errors) (only (set-compute-and-apply-fn generic-function-p methodp call-method-by-list) generics) class-names) () (expose arith bci lists classes sockets streams ccc symbols strings calls others tables vectors (except (error cerror) errors) (only (set-compute-and-apply-fn generic-function-p methodp call-method-by-list) generics) class-names) (export <object>) (set-class-of <object> <class>) (export <class>) (set-class-of <class> <class>) (defconstant <instantiable-class> (allocate-object <class>)) (export <instantiable-class>) (set-class-of <instantiable-class> <class>) (defconstant <si-class> (allocate-object <class>)) (export <si-class>) (set-class-of <si-class> <class>) (defconstant <abstract-class> (allocate-object <class>)) (export <abstract-class>) (set-class-of <abstract-class> <class>) (defconstant <structure-class> (allocate-object <class>)) (export <structure-class>) (set-class-of <structure-class> <class>) (defconstant <mi-class> (allocate-object <class>)) (export <mi-class>) (set-class-of <mi-class> <class>) (defconstant <slot-description-class> (allocate-object <class>)) (export <slot-description-class>) (set-class-of <slot-description-class> <class>) (defconstant <structure> (allocate-object <class>)) (export <structure>) (set-class-of <structure> <structure-class>) (defconstant <slot-description> (allocate-object <class>)) (export <slot-description>) (set-class-of <slot-description> <slot-description-class>) (defconstant <local-slot-description> (allocate-object <class>)) (export <local-slot-description>) (set-class-of <local-slot-description> <class>) (defconstant <unreadable-slot-description> (allocate-object <class>)) (export <unreadable-slot-description>) (set-class-of <unreadable-slot-description> <slot-description-class>) (export <funcallable-object-class>) (set-class-of <funcallable-object-class> <class>) (export <generic-class>) (set-class-of <generic-class> <class>) (export <bytefunction-class>) (set-class-of <bytefunction-class> <class>) (defconstant <funcallable-object> (allocate-object <class>)) (export <funcallable-object>) (set-class-of <funcallable-object> <funcallable-object-class>) (export <function>) (set-class-of <function> <funcallable-object-class>) (export <i-function>) (set-class-of <i-function> <funcallable-object-class>) (export <c-function>) (set-class-of <c-function> <funcallable-object-class>) (export <bytefunction>) (set-class-of <bytefunction> <bytefunction-class>) (export <extended-bytefunction>) (set-class-of <extended-bytefunction> <bytefunction-class>) (export <generic-function>) (set-class-of <generic-function> <generic-class>) (export <method-class>) (set-class-of <method-class> <class>) (export <method>) (set-class-of <method> <method-class>) (export <condition-class>) (set-class-of <condition-class> <class>) (export <condition>) (set-class-of <condition> <condition-class>) (export <Internal-Error>) (set-class-of <Internal-Error> <condition-class>) (export <clock-tick>) (set-class-of <clock-tick> <condition-class>) (defconstant <invalid-operator> (allocate-object <class>)) (export <invalid-operator>) (set-class-of <invalid-operator> <condition-class>) (export <thread-class>) (set-class-of <thread-class> <class>) (export <thread>) (set-class-of <thread> <thread-class>) (export <primitive-class>) (set-class-of <primitive-class> <class>) (export <character>) (set-class-of <character> <primitive-class>) (export <symbol>) (set-class-of <symbol> <primitive-class>) (export <weak-wrapper>) (set-class-of <weak-wrapper> <primitive-class>) (export <continuation>) (set-class-of <continuation> <primitive-class>) (export <socket>) (set-class-of <socket> <primitive-class>) (export <listener>) (set-class-of <listener> <primitive-class>) (defconstant <collection> (allocate-object <class>)) (export <collection>) (set-class-of <collection> <abstract-class>) (export <table>) (set-class-of <table> <class>) (defconstant <sequence> (allocate-object <class>)) (export <sequence>) (set-class-of <sequence> <abstract-class>) (export <string>) (set-class-of <string> <primitive-class>) (defconstant <vector-class> (allocate-object <class>)) (export <vector-class>) (set-class-of <vector-class> <class>) (export <vector>) (set-class-of <vector> <vector-class>) (defconstant <number-class> (allocate-object <class>)) (export <number-class>) (set-class-of <number-class> <class>) (export <number>) (set-class-of <number> <number-class>) (defconstant <float> (allocate-object <class>)) (export <float>) (set-class-of <float> <class>) (export <double-float>) (set-class-of <double-float> <number-class>) (defconstant <integer> (allocate-object <class>)) (export <integer>) (set-class-of <integer> <number-class>) (export <fixint>) (set-class-of <fixint> <number-class>) (defconstant <list> (allocate-object <class>)) (export <list>) (set-class-of <list> <class>) (export <pair>) (set-class-of <pair> <primitive-class>) (export <null>) (set-class-of <null> <primitive-class>) (defconstant <special-method> (allocate-object <class>)) (export <special-method>) (set-class-of <special-method> <class>) (defconstant mapcar1 mapcar) (defconstant mapc1 mapc) (defconstant unbound-slot-value (quote %_*unbound*_%)) (export unbound-slot-value class-type) (defconstant generic-type 164) (defconstant method-type 37) (defconstant class-type 13) (defun fill-class (class desc) (primitive-set-slot-ref-1 class (car desc)) (setq desc (cdr desc)) (primitive-set-slot-ref-0 class (car desc)) (setq desc (cdr desc)) (primitive-set-slot-ref-8 class (car desc)) (setq desc (cdr desc)) (primitive-set-slot-ref-2 class (car desc)) (setq desc (cdr desc)) (primitive-set-slot-ref-7 class (car desc)) (setq desc (cdr desc)) (primitive-set-slot-ref-3 class nil) (set-type class class-type) (mapc1 (lambda (cl) (primitive-set-slot-ref-3 cl (cons class (primitive-slot-ref-3 cl)))) (primitive-slot-ref-2 class))) (defun initialise-hierarchy (lst) (if (null lst) nil (progn (fill-class (car (car lst)) (cdr (car lst))) (initialise-hierarchy (cdr lst))))) (initialise-hierarchy (list (list <object> (quote <object>) 0 (quote ()) (list) (list <object>)) (list <class> (quote <class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <object>) (list <class> <object>)) (list <instantiable-class> (quote <instantiable-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <instantiable-class> <class> <object>)) (list <si-class> (quote <si-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <instantiable-class>) (list <si-class> <instantiable-class> <class> <object>)) (list <abstract-class> (quote <abstract-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <abstract-class> <class> <object>)) (list <structure-class> (quote <structure-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <si-class>) (list <structure-class> <si-class> <instantiable-class> <class> <object>)) (list <mi-class> (quote <mi-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <instantiable-class>) (list <mi-class> <instantiable-class> <class> <object>)) (list <slot-description-class> (quote <slot-description-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <slot-description-class> <class> <object>)) (list <structure> (quote <structure>) 0 (quote ()) (list <object>) (list <structure> <object>)) (list <slot-description> (quote <slot-description>) 6 (quote (name position initfunction reader writer initarg)) (list <object>) (list <slot-description> <object>)) (list <local-slot-description> (quote <local-slot-description>) 6 (quote (name position initfunction reader writer initarg)) (list <slot-description>) (list <local-slot-description> <slot-description> <object>)) (list <unreadable-slot-description> (quote <unreadable-slot-description>) 6 (quote (name position initfunction reader writer initarg)) (list <local-slot-description>) (list <unreadable-slot-description> <local-slot-description> <slot-description> <object>)) (list <funcallable-object-class> (quote <funcallable-object-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <funcallable-object-class> <class> <object>)) (list <generic-class> (quote <generic-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <funcallable-object-class>) (list <generic-class> <funcallable-object-class> <class> <object>)) (list <bytefunction-class> (quote <bytefunction-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <funcallable-object-class>) (list <bytefunction-class> <funcallable-object-class> <class> <object>)) (list <funcallable-object> (quote <funcallable-object>) 0 (quote ()) (list <object>) (list <funcallable-object> <object>)) (list <function> (quote <function>) 5 (quote ()) (list <funcallable-object>) (list <function> <funcallable-object> <object>)) (list <i-function> (quote <i-function>) 6 (quote ()) (list <function>) (list <i-function> <function> <funcallable-object> <object>)) (list <c-function> (quote <c-function>) 5 (quote ()) (list <function>) (list <c-function> <function> <funcallable-object> <object>)) (list <bytefunction> (quote <bytefunction>) 5 (quote ()) (list <funcallable-object>) (list <bytefunction> <funcallable-object> <object>)) (list <extended-bytefunction> (quote <extended-bytefunction>) 6 (quote ()) (list <bytefunction>) (list <extended-bytefunction> <bytefunction> <funcallable-object> <object>)) (list <generic-function> (quote <generic-function>) 10 (quote (method-class methods domain)) (list <funcallable-object>) (list <generic-function> <funcallable-object> <object>)) (list <method-class> (quote <method-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <method-class> <class> <object>)) (list <method> (quote <method>) 5 (quote (domain range function signature)) (list <object>) (list <method> <object>)) (list <condition-class> (quote <condition-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <condition-class> <class> <object>)) (list <condition> (quote <condition>) 2 (quote (message error-value)) (list <object>) (list <condition> <object>)) (list <Internal-Error> (quote <Internal-Error>) 2 (quote (message error-value)) (list <condition>) (list <Internal-Error> <condition> <object>)) (list <clock-tick> (quote <clock-tick>) 2 (quote (message error-value)) (list <condition>) (list <clock-tick> <condition> <object>)) (list <invalid-operator> (quote <invalid-operator>) 4 (quote (message error-value)) (list <condition>) (list <invalid-operator> <condition> <object>)) (list <thread-class> (quote <thread-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <thread-class> <class> <object>)) (list <thread> (quote <thread>) 7 (quote ()) (list <object>) (list <thread> <object>)) (list <primitive-class> (quote <primitive-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <class>) (list <primitive-class> <class> <object>)) (list <character> (quote <character>) 0 (quote ()) (list <object>) (list <character> <object>)) (list <symbol> (quote <symbol>) 0 (quote ()) (list <object>) (list <symbol> <object>)) (list <weak-wrapper> (quote <weak-wrapper>) 0 (quote ()) (list <object>) (list <weak-wrapper> <object>)) (list <continuation> (quote <continuation>) 0 (quote ()) (list <funcallable-object>) (list <continuation> <funcallable-object> <object>)) (list <socket> (quote <socket>) 0 (quote ()) (list <object>) (list <socket> <object>)) (list <listener> (quote <listener>) 0 (quote ()) (list <object>) (list <listener> <object>)) (list <collection> (quote <collection>) 0 (quote ()) (list <object>) (list <collection> <object>)) (list <table> (quote <table>) 7 (quote ()) (list <collection>) (list <table> <collection> <object>)) (list <sequence> (quote <sequence>) 0 (quote ()) (list <collection>) (list <sequence> <collection> <object>)) (list <string> (quote <string>) 0 (quote ()) (list <sequence>) (list <string> <sequence> <collection> <object>)) (list <vector-class> (quote <vector-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <primitive-class>) (list <vector-class> <primitive-class> <class> <object>)) (list <vector> (quote <vector>) 0 (quote ()) (list <sequence>) (list <vector> <sequence> <collection> <object>)) (list <number-class> (quote <number-class>) 10 (quote (direct-superclasses direct-slot-descriptions direct-initargs name)) (list <primitive-class>) (list <number-class> <primitive-class> <class> <object>)) (list <number> (quote <number>) 0 (quote ()) (list <object>) (list <number> <object>)) (list <float> (quote <float>) 0 (quote ()) (list <number>) (list <float> <number> <object>)) (list <double-float> (quote <double-float>) 0 (quote ()) (list <float>) (list <double-float> <float> <number> <object>)) (list <integer> (quote <integer>) 0 (quote ()) (list <number>) (list <integer> <number> <object>)) (list <fixint> (quote <fixint>) 0 (quote ()) (list <integer>) (list <fixint> <integer> <number> <object>)) (list <list> (quote <list>) 0 (quote ()) (list <sequence>) (list <list> <sequence> <collection> <object>)) (list <pair> (quote <pair>) 0 (quote ()) (list <list>) (list <pair> <list> <sequence> <collection> <object>)) (list <null> (quote <null>) 0 (quote ()) (list <list>) (list <null> <list> <sequence> <collection> <object>)) (list <special-method> (quote <special-method>) 1 (quote (id)) (list <object>) (list <special-method> <object>)))) (defun i-add1 (x) (binary+_Integer x 1)) (defun i-sub1 (x) (binary-_Integer x 1)) (defun i-zerop (x) (binary=_Integer 0 x)) (defun i-greaterp (x y) (binary<_Integer y x)) (defun fold (fn lst val) (if (null lst) val (fold fn (cdr lst) (fn (car lst) val)))) (export fold) (defun reverse (x) (fold cons x nil)) (defun assq (x lst) (if (null lst) nil (if (eq (car (car lst)) x) (car lst) (assq x (cdr lst))))) (defun identity (x) x) (defconstant slot-readers (make-initialized-vector primitive-slot-ref-0 primitive-slot-ref-1 primitive-slot-ref-2 primitive-slot-ref-3 primitive-slot-ref-4 primitive-slot-ref-5 primitive-slot-ref-6 primitive-slot-ref-7 primitive-slot-ref-8 primitive-slot-ref-9)) (defconstant slot-writers (make-initialized-vector primitive-set-slot-ref-0 primitive-set-slot-ref-1 primitive-set-slot-ref-2 primitive-set-slot-ref-3 primitive-set-slot-ref-4 primitive-set-slot-ref-5 primitive-set-slot-ref-6 primitive-set-slot-ref-7 primitive-set-slot-ref-8 primitive-set-slot-ref-9)) (defun %compute-reader (n) (if (i-greaterp 10 n) (vector-ref slot-readers n) (lambda (***method-status-handle*** ***method-args-handle*** x) (primitive-slot-ref x n)))) (defun %compute-writer (n) (if (i-greaterp 10 n) (vector-ref slot-writers n) (lambda (***method-status-handle*** ***method-args-handle*** x v) (primitive-set-slot-ref x n v)))) (defun make-initial-table (key entry) (mk-tab-aux key entry)) (defun mk-tab-aux (key entry) ((lambda (add-part) (setq add-part (lambda (lst tab) (if (null lst) tab (add-part (cdr lst) (cons (cons (car lst) tab) nil))))) (add-part (reverse key) entry)) ())) (defun add-table-entry (table key value) (if (null table) (error "Can't happen" <Internal-Error>) ((lambda (xx) (if (null xx) (progn (nconc table (make-initial-table key value)) table) (if (null (cdr key)) (primitive-set-slot-ref-1 xx value) (add-table-entry (cdr xx) (cdr key) value)))) (assq (car key) table)))) (defun symbol-unbraced-name (sym) ((lambda (x) (if (eq (string-ref x 0) #\<) (substring x 1 (i-sub1 (i-sub1 (string-length x)))) x)) (symbol-name sym))) (export symbol-unbraced-name) (defun scan-args (arg init-lst panic) ((lambda (scan-aux) (setq scan-aux (lambda (arg lst) (if (null lst) (panic arg init-lst) (if (eq (car lst) arg) (car (cdr lst)) (scan-aux arg (cdr (cdr lst))))))) (scan-aux arg init-lst)) ())) (defun required-argument (arg args) (error "Missing init-argument" <Internal-Error> (quote error-value) arg)) (defun unbound-argument (arg args) unbound-slot-value) (defun null-argument (arg args) nil) (defun default-argument (x) (lambda (arg args) x)) (export required-argument unbound-argument null-argument default-argument scan-args) (defun simple-compute-method-lookup-function (gf domain) (lambda (args) (find-applicable-methods gf args))) (defun %generic-domain (gf) ((lambda (dom) (if dom dom ((lambda (obj) (primitive-set-slot-ref-1 obj obj) obj) (list <object>)))) (cdr (primitive-slot-ref-6 gf)))) (defun method-signature-depth (gf meth) ((lambda (sig domain) ((lambda (calc-depth) (setq calc-depth (lambda (lst domain depth n) (if (null lst) depth (if (eq (car lst) (car domain)) (calc-depth (cdr lst) (cdr domain) depth (i-add1 n)) (calc-depth (cdr lst) (cdr domain) (i-add1 n) (i-add1 n)))))) (calc-depth sig domain 0 0)) ())) (primitive-slot-ref-1 meth) (%generic-domain gf))) (defun simple-add-method (gf meth) ((lambda (sig table) (if (null table) (primitive-set-slot-ref-5 gf (make-initial-table sig (list meth))) (add-table-entry table sig (list meth))) (primitive-set-slot-ref-3 gf nil) (primitive-set-slot-ref-4 gf nil) (primitive-set-slot-ref-2 meth gf) ((lambda (true-depth) (if (i-greaterp true-depth (primitive-slot-ref-8 gf)) (primitive-set-slot-ref-8 gf true-depth) nil)) (method-signature-depth gf meth)) gf) (primitive-slot-ref-1 meth) (primitive-slot-ref-5 gf))) (defun std-generic-discriminator (gf lookup) (lambda (args) ((lambda (meths) (if (null meths) (error "No applicable method" no-applicable-method (quote sig) (mapcar1 class-of args)) (call-method-by-list meths args))) (lookup args)))) (defun simple-make-generic args ((lambda (obj) (primitive-set-slot-ref-0 obj (scan-args (quote name) args required-argument)) (primitive-set-slot-ref-2 obj (scan-args (quote argtype) args required-argument)) (primitive-set-slot-ref-3 obj nil) (primitive-set-slot-ref-4 obj nil) (primitive-set-slot-ref-5 obj nil) (primitive-set-slot-ref-6 obj (cons <method> (scan-args (quote domain) args null-argument))) ((lambda (lookup) (primitive-set-slot-ref-7 obj lookup) (primitive-set-slot-ref-1 obj (std-generic-discriminator obj lookup))) (simple-compute-method-lookup-function obj nil)) (primitive-set-slot-ref-8 obj 0) (set-type obj generic-type) obj) (allocate-object <generic-function>))) (defun simple-make-method args ((lambda (meth) (primitive-set-slot-ref-0 meth nil) (primitive-set-slot-ref-2 meth nil) (primitive-set-slot-ref-1 meth (scan-args (quote signature) args required-argument)) (primitive-set-slot-ref-3 meth (scan-args (quote function) args required-argument)) (primitive-set-slot-ref-4 meth (scan-args (quote fixed) args null-argument)) (set-type meth method-type) meth) (allocate-object <method>))) (defun simple-compute-reader (cl args) ((lambda (pos gf) (if (eq (scan-args (quote class) args null-argument) <unreadable-slot-description>) (simple-add-method gf (simple-make-method (quote signature) (list cl) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** o) (error "Can't read slot" <Internal-Error>)))) (simple-add-method gf (simple-make-method (quote signature) (list cl) (quote function) (%compute-reader pos)))) gf) (scan-args (quote position) args required-argument) (simple-make-generic (quote argtype) 1 (quote name) (make-symbol (string-append (symbol-unbraced-name (scan-args (quote owner-class) args (default-argument (quote anonymous)))) (string-append "-" (symbol-name (scan-args (quote name) args required-argument)))))))) (defun simple-compute-writer (cl args) ((lambda (pos gf) (if (eq (scan-args (quote class) args null-argument) <unreadable-slot-description>) (simple-add-method gf (simple-make-method (quote signature) (list cl <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** o v) (error "Can't set slot" <Internal-Error>)))) (simple-add-method gf (simple-make-method (quote signature) (list cl <object>) (quote function) (%compute-writer pos)))) gf) (scan-args (quote position) args null-argument) (simple-make-generic (quote argtype) 2 (quote domain) (list cl <object>) (quote name) (make-symbol (string-append (string-append (symbol-name (scan-args (quote owner-class) args (default-argument (quote anonymous)))) (string-append "-" (symbol-name (scan-args (quote name) args required-argument)))) "-setter"))))) (defun fill-slot-description (obj class args) ((lambda (access-args) (setq args (cdr (cdr args))) (primitive-set-slot-ref-0 obj (car args)) (setq args (cdr args)) (primitive-set-slot-ref-1 obj (car args)) (setq args (cdr args)) ((lambda (initform) (primitive-set-slot-ref-3 obj (if (eq initform unbound-slot-value) unbound-slot-value (lambda () initform)))) (car args)) (setq args (cdr args)) (primitive-set-slot-ref-2 obj (car args)) (primitive-set-slot-ref-5 obj (simple-compute-reader class access-args)) (primitive-set-slot-ref-4 obj (simple-compute-writer class access-args)) obj) (list (quote class) (car args) (quote owner-class) (car (cdr args)) (quote name) (car (cdr (cdr args))) (quote position) (car (cdr (cdr (cdr args))))))) (defun simple-find-slot-description (class name) ((lambda (xx) ((lambda (l1) (setq l1 (lambda (slots) (if (null slots) (error "Could not find slot" <Internal-Error> (quote error-value) name) (if (eq (primitive-slot-ref-0 (car slots)) name) (car slots) (l1 (cdr slots)))))) (l1 xx)) ())) (primitive-slot-ref-5 class))) (defun simple-find-slot-reader (class slot-name) (primitive-slot-ref-5 (simple-find-slot-description class slot-name))) (defun simple-find-slot-writer (class slot-name) (primitive-slot-ref-4 (simple-find-slot-description class slot-name))) (defun simple-find-accessor (class slot-name) ((lambda (reader writer) (primitive-set-slot-ref-9 reader writer) reader) (simple-find-slot-reader class slot-name) (simple-find-slot-writer class slot-name))) (defun initialize-slots (lst) (if (null lst) nil ((lambda (class slots) (primitive-set-slot-ref-5 class (append (if (null (primitive-slot-ref-2 class)) nil (primitive-slot-ref-5 (car (primitive-slot-ref-2 class)))) (make-slot-list class slots))) (primitive-set-slot-ref-4 class (mapcar1 (lambda (sd) nil) (primitive-slot-ref-5 class))) (primitive-set-slot-ref-6 class (primitive-slot-ref-5 class)) (initialize-slots (cdr lst))) (car (car lst)) (cdr (car lst))))) (defun make-slot-list (class slotds) (if (null slotds) nil ((lambda (slotd slot) (fill-slot-description slot class (cons (car slotd) (cons (primitive-slot-ref-1 class) (cdr slotd)))) (cons slot (make-slot-list class (cdr slotds)))) (car slotds) (allocate-object (car (car slotds)))))) (defconstant internal-gf-setter-setter primitive-set-slot-ref-9) (defconstant internal-gf-setter primitive-slot-ref-9) (defconstant internal-gf-method-table (lambda (x) (primitive-slot-ref-5 x))) (defconstant internal-gf-name (lambda (x) (primitive-slot-ref-0 x))) (defconstant internal-gf-discrimination-depth (lambda (x) (primitive-slot-ref-8 x))) (defconstant internal-gf-method-lookup-function (lambda (x) (primitive-slot-ref-7 x))) (defconstant internal-class-precedence-list (lambda (x) (primitive-slot-ref-7 x))) (defun init-generic (gf) ((lambda (lookup) (primitive-set-slot-ref-7 gf lookup) (primitive-set-slot-ref-1 gf (std-generic-discriminator gf lookup)) (primitive-set-slot-ref-6 gf (cons <method> nil))) (simple-compute-method-lookup-function gf nil))) (defun add-method-to-caches (gf sig meths) (primitive-set-slot-ref-3 gf (cons sig meths)) ((lambda (table) (if (null table) (primitive-set-slot-ref-4 gf (make-initial-table sig (cons sig meths))) (add-table-entry table sig (cons sig meths)))) (primitive-slot-ref-4 gf))) (initialize-slots (list (list <object>) (list <class> (list <local-slot-description> (quote instance-size) 0 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote name) 1 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote super-classes) 2 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote subclasses) 3 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote local-slot-descriptions) 4 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote slot-descriptions) 5 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote non-local-descriptions) 6 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote precedence) 7 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote initargs) 8 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote spare) 9 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <instantiable-class>) (list <si-class>) (list <abstract-class>) (list <structure-class>) (list <mi-class>) (list <slot-description-class>) (list <structure>) (list <slot-description> (list <local-slot-description> (quote name) 0 (quote %_*unbound*_%) (quote name)) (list <local-slot-description> (quote position) 1 (quote %_*unbound*_%) (quote position)) (list <local-slot-description> (quote initarg) 2 (quote %_*unbound*_%) (quote initarg)) (list <local-slot-description> (quote initfunction) 3 (quote %_*unbound*_%) (quote initfunction)) (list <local-slot-description> (quote slot-writer) 4 (quote %_*unbound*_%) (quote writer)) (list <local-slot-description> (quote slot-reader) 5 (quote %_*unbound*_%) (quote reader))) (list <local-slot-description>) (list <unreadable-slot-description>) (list <funcallable-object-class>) (list <generic-class>) (list <bytefunction-class>) (list <funcallable-object>) (list <function> (list <unreadable-slot-description> (quote argtype) 0 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <unreadable-slot-description> (quote env) 1 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <unreadable-slot-description> (quote xxx) 2 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote name) 3 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote home) 4 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <i-function> (list <local-slot-description> (quote body) 5 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <c-function>) (list <bytefunction> (list <local-slot-description> (quote env) 0 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote offset) 1 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote nargs) 2 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote globals) 3 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote setter) 4 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <extended-bytefunction> (list <local-slot-description> (quote info) 5 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <generic-function> (list <local-slot-description> (quote name) 0 (quote %_*unbound*_%) (quote name)) (list <local-slot-description> (quote discriminator) 1 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote argtype) 2 (quote %_*unbound*_%) (quote argtype)) (list <local-slot-description> (quote fast-cache) 3 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote slow-cache) 4 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote method-table) 5 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote method-description) 6 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote method-lookup-function) 7 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote discrimination-depth) 8 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote setter) 9 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <method-class>) (list <method> (list <local-slot-description> (quote method-qualifier) 0 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote signature) 1 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote generic-function) 2 (quote ()) (quote %_*unbound*_%)) (list <local-slot-description> (quote function) 3 (quote %_*unbound*_%) (quote function)) (list <local-slot-description> (quote fixed) 4 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <condition-class>) (list <condition> (list <local-slot-description> (quote message) 0 (quote %_*unbound*_%) (quote message)) (list <local-slot-description> (quote error-value) 1 (quote %_*unbound*_%) (quote error-value))) (list <Internal-Error>) (list <clock-tick>) (list <invalid-operator> (list <local-slot-description> (quote args) 2 (quote %_*unbound*_%) (quote args)) (list <local-slot-description> (quote op) 3 (quote %_*unbound*_%) (quote op))) (list <thread-class>) (list <thread> (list <local-slot-description> (quote data) 0 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote state) 1 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <unreadable-slot-description> (quote fun) 2 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote args) 3 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote value) 4 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <unreadable-slot-description> (quote cochain) 5 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote signal-list) 6 (quote %_*unbound*_%) (quote %_*unbound*_%))) (list <primitive-class>) (list <character>) (list <symbol>) (list <weak-wrapper>) (list <continuation>) (list <socket>) (list <listener>) (list <collection>) (list <table> (list <local-slot-description> (quote table-values) 0 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote table-population) 1 (quote 0) (quote %_*unbound*_%)) (list <local-slot-description> (quote table-threshold) 2 (quote 14) (quote %_*unbound*_%)) (list <local-slot-description> (quote table-filled) 3 (quote %_*unbound*_%) (quote %_*unbound*_%)) (list <local-slot-description> (quote table-comparator) 4 (quote ()) (quote comparator)) (list <local-slot-description> (quote table-hash-function) 5 (quote ()) (quote hash-function)) (list <local-slot-description> (quote table-fill) 6 (quote ()) (quote fill))) (list <sequence>) (list <string>) (list <vector-class>) (list <vector>) (list <number-class>) (list <number>) (list <float>) (list <double-float>) (list <integer>) (list <fixint>) (list <list>) (list <pair>) (list <null>) (list <special-method> (list <local-slot-description> (quote id) 0 (quote %_*unbound*_%) (quote id))))) (defconstant class-instance-size (simple-find-accessor <class> (quote instance-size))) (export class-instance-size) (defconstant class-name (simple-find-accessor <class> (quote name))) (export class-name) (defconstant class-direct-superclasses (simple-find-accessor <class> (quote super-classes))) (export class-direct-superclasses) (defconstant class-direct-subclasses (simple-find-accessor <class> (quote subclasses))) (export class-direct-subclasses) (defconstant class-local-slot-descriptions (simple-find-accessor <class> (quote local-slot-descriptions))) (export class-local-slot-descriptions) (defconstant class-slot-descriptions (simple-find-accessor <class> (quote slot-descriptions))) (export class-slot-descriptions) (defconstant class-non-local-slot-descriptions (simple-find-accessor <class> (quote non-local-descriptions))) (export class-non-local-slot-descriptions) (defconstant class-precedence-list (simple-find-accessor <class> (quote precedence))) (export class-precedence-list) (defconstant class-initargs (simple-find-accessor <class> (quote initargs))) (export class-initargs) (defconstant class-spare (simple-find-accessor <class> (quote spare))) (export class-spare) (defconstant slot-description-name (simple-find-accessor <slot-description> (quote name))) (export slot-description-name) (defconstant slot-description-position (simple-find-accessor <slot-description> (quote position))) (export slot-description-position) (defconstant slot-description-initarg (simple-find-accessor <slot-description> (quote initarg))) (export slot-description-initarg) (defconstant slot-description-initfunction (simple-find-accessor <slot-description> (quote initfunction))) (export slot-description-initfunction) (defconstant slot-description-slot-writer (simple-find-accessor <slot-description> (quote slot-writer))) (export slot-description-slot-writer) (defconstant slot-description-slot-reader (simple-find-accessor <slot-description> (quote slot-reader))) (export slot-description-slot-reader) (defconstant function-name (simple-find-accessor <function> (quote name))) (export function-name) (defconstant function-home (simple-find-accessor <function> (quote home))) (export function-home) (defconstant i-function-body (simple-find-accessor <i-function> (quote body))) (export i-function-body) (defconstant bytefunction-env (simple-find-accessor <bytefunction> (quote env))) (export bytefunction-env) (defconstant extended-bytefunction-info (simple-find-accessor <extended-bytefunction> (quote info))) (export extended-bytefunction-info) (defconstant generic-name (simple-find-accessor <generic-function> (quote name))) (export generic-name) (defconstant generic-discriminator (simple-find-accessor <generic-function> (quote discriminator))) (export generic-discriminator) (defconstant generic-argtype (simple-find-accessor <generic-function> (quote argtype))) (export generic-argtype) (defconstant generic-fast-cache (simple-find-accessor <generic-function> (quote fast-cache))) (export generic-fast-cache) (defconstant generic-slow-cache (simple-find-accessor <generic-function> (quote slow-cache))) (export generic-slow-cache) (defconstant generic-method-table (simple-find-accessor <generic-function> (quote method-table))) (export generic-method-table) (defconstant generic-method-description (simple-find-accessor <generic-function> (quote method-description))) (export generic-method-description) (defconstant generic-method-lookup-function (simple-find-accessor <generic-function> (quote method-lookup-function))) (export generic-method-lookup-function) (defconstant generic-discrimination-depth (simple-find-accessor <generic-function> (quote discrimination-depth))) (export generic-discrimination-depth) (defconstant generic-setter (simple-find-accessor <generic-function> (quote setter))) (export generic-setter) (defconstant method-qualifier (simple-find-accessor <method> (quote method-qualifier))) (export method-qualifier) (defconstant method-signature (simple-find-accessor <method> (quote signature))) (export method-signature) (defconstant method-generic-function (simple-find-accessor <method> (quote generic-function))) (export method-generic-function) (defconstant method-function (simple-find-accessor <method> (quote function))) (export method-function) (defconstant method-fixed (simple-find-accessor <method> (quote fixed))) (export method-fixed) (defconstant condition-message (simple-find-accessor <condition> (quote message))) (export condition-message) (defconstant condition-error-value (simple-find-accessor <condition> (quote error-value))) (export condition-error-value) (defconstant invalid-operator-args (simple-find-accessor <invalid-operator> (quote args))) (export invalid-operator-args) (defconstant invalid-operator-op (simple-find-accessor <invalid-operator> (quote op))) (export invalid-operator-op) (defconstant thread-internal-state (simple-find-accessor <thread> (quote state))) (export thread-internal-state) (defconstant thread-args (simple-find-accessor <thread> (quote args))) (export thread-args) (defconstant thread-cochain (simple-find-accessor <thread> (quote cochain))) (export thread-cochain) (defconstant thread-signals (simple-find-accessor <thread> (quote signal-list))) (export thread-signals) (defconstant table-values (simple-find-accessor <table> (quote table-values))) (export table-values) (defconstant table-population (simple-find-accessor <table> (quote table-population))) (export table-population) (defconstant table-threshold (simple-find-accessor <table> (quote table-threshold))) (export table-threshold) (defconstant table-filled (simple-find-accessor <table> (quote table-filled))) (export table-filled) (defconstant table-comparator (simple-find-accessor <table> (quote table-comparator))) (export table-comparator) (defconstant table-hash-function (simple-find-accessor <table> (quote table-hash-function))) (export table-hash-function) (defconstant table-fill (simple-find-accessor <table> (quote table-fill))) (export table-fill) (defconstant sm-id (simple-find-accessor <special-method> (quote id))) (export sm-id) (defun stable-generic-method-table (gf) (if (eq (class-of gf) <generic-function>) (internal-gf-method-table gf) (generic-method-table gf))) (defun stable-generic-lookup-function (gf) (if (eq (class-of gf) <generic-function>) (internal-gf-method-lookup-function gf) (generic-method-lookup-function gf))) (defun stable-generic-name (gf) (if (eq (class-of gf) <generic-function>) (internal-gf-name gf) (generic-name gf))) (defun stable-generic-discrimination-depth (gf) (if (eq (class-of gf) <generic-function>) (internal-gf-discrimination-depth gf) (generic-discrimination-depth gf))) (defun stable-class-precedence-list (cl) (if (eq (class-of cl) <class>) (internal-class-precedence-list cl) (class-precedence-list cl))) (defconstant setter (simple-make-generic (quote argtype) 1 (quote name) (quote setter))) (export setter) (defconstant setter-setter (simple-make-generic (quote argtype) 2 (quote name) (quote setter-setter))) (export setter-setter) (simple-add-method setter-setter (simple-make-method (quote signature) (list <generic-function> <object>) (quote function) internal-gf-setter-setter)) (simple-add-method setter (simple-make-method (quote signature) (list <generic-function>) (quote function) internal-gf-setter)) (defun generic-method-class (gf) (car (generic-method-description gf))) (defun generic-method-domain (gf) (cdr (generic-method-description gf))) (export generic-method-domain generic-method-class) (defun set-generic-method-description (gf class domain) ((setter generic-method-description) gf (cons class domain))) (defconstant add-method-method (lambda (***method-status-handle*** ***method-args-handle*** gf meth) (if (= (generic-argtype gf) (list-length (method-signature meth))) ((lambda (sig table) (if (null table) ((generic-setter generic-method-table) gf (make-initial-table sig (list meth))) (add-table-entry table sig (list meth))) ((lambda (true-depth) (if (i-greaterp true-depth (generic-discrimination-depth gf)) ((generic-setter generic-discrimination-depth) gf true-depth) nil)) (method-signature-depth gf meth)) ((generic-setter generic-fast-cache) gf nil) ((generic-setter generic-slow-cache) gf nil) ((setter method-generic-function) meth gf) gf) (restrict-method gf (method-signature meth)) (generic-method-table gf)) (error "add-method: argument mismatch" <Internal-Error> (quote error-value) (cons gf meth))))) (export add-method-method) (defun trim-signature (gf sig) (if (i-zerop (stable-generic-discrimination-depth gf)) nil ((lambda (add-obj) (setq add-obj (lambda (last lst n) (if (i-zerop n) nil (progn ((lambda (new) (primitive-set-slot-ref-1 last new) (add-obj new (cdr lst) (i-sub1 n))) (cons (car lst) nil)))))) ((lambda (first) (add-obj first (cdr sig) (i-sub1 (stable-generic-discrimination-depth gf))) first) (cons (car sig) nil))) ()))) (defun find-applicable-methods (gf args) (find-applic-methods-aux (stable-generic-method-table gf) (mapcar1 (lambda (x) (stable-class-precedence-list (class-of x))) args))) (defun find-applic-methods-aux (table cpl-lst) (if (null cpl-lst) nil (if (null (car cpl-lst)) nil ((lambda (xx) (if (null xx) (find-applic-methods-aux table (cons (cdr (car cpl-lst)) (cdr cpl-lst))) (if (null (cdr cpl-lst)) (if (methodp (car (cdr xx))) (cons (car (cdr xx)) (find-applic-methods-aux table (cons (cdr (car cpl-lst)) (cdr cpl-lst)))) (progn (cerror "yowzer" <Internal-Error> (quote error-value) xx))) (append (find-applic-methods-aux (cdr xx) (cdr cpl-lst)) (find-applic-methods-aux table (cons (cdr (car cpl-lst)) (cdr cpl-lst))))))) (assq (car (car cpl-lst)) table))))) (deflocal debug nil) (defun find-and-call-generic (gf args) ((lambda (meths sig) (if (null meths) (error "No applicable methods" no-applicable-method (quote error-value) gf (quote sig) sig (quote args) args) ((lambda (trimmed-sig) (add-method-to-caches gf trimmed-sig meths) (call-method-by-list meths args)) (trim-signature gf sig)))) ((stable-generic-lookup-function gf) args) (mapcar1 class-of args))) (defun restrict-method (gf sig) ((lambda (domain) (if (null domain) sig ((lambda (restrict-lsts) (setq restrict-lsts (lambda (sig dom) (if (null sig) nil (if (subclassp (car sig) (car dom)) (cons (car sig) (restrict-lsts (cdr sig) (cdr dom))) (if (subclassp (car dom) (car sig)) (cons (car dom) (restrict-lsts (cdr sig) (cdr dom))) (progn (error "Add-method: outside domain" <Internal-Error>) 2)))))) (restrict-lsts sig domain)) ()))) (generic-method-domain gf))) (set-compute-and-apply-fn find-and-call-generic) (defconstant add-method (simple-make-generic (quote argtype) 2 (quote lambda-list) (quote (object lst)) (quote name) (quote add-method))) (export add-method) (defconstant compute-method-lookup-function (simple-make-generic (quote argtype) 2 (quote lambda-list) (quote (object lst)) (quote name) (quote compute-method-lookup-function))) (export compute-method-lookup-function) (defconstant compute-discriminating-function (simple-make-generic (quote argtype) 4 (quote lambda-list) (quote (object lst object object)) (quote name) (quote compute-discriminating-function))) (export compute-discriminating-function) (defconstant = (simple-make-generic (quote argtype) 2 (quote lambda-list) (quote (x y)) (quote name) (quote =))) (export =) (defconstant std-allocate-object (lambda (***method-status-handle*** ***method-args-handle*** a b) (allocate-object a))) (defconstant std-initialize-object (lambda (***method-status-handle*** ***method-args-handle*** obj initlist) (initialize-local-slots obj initlist) (mapc1 (lambda (slot) ((lambda (initarg initfunction) (if (eq initarg unbound-slot-value) (if (eq initfunction unbound-slot-value) nil ((slot-description-slot-writer slot) obj (initfunction))) ((lambda (value) (if (eq value unbound-slot-value) (if (eq initfunction unbound-slot-value) nil ((slot-description-slot-writer slot) obj (initfunction))) ((slot-description-slot-writer slot) obj value))) (scan-args initarg initlist unbound-argument)))) (slot-description-initarg slot) (slot-description-initfunction slot))) (class-non-local-slot-descriptions (class-of obj))) obj)) (init-generic allocate) (init-generic initialize) (init-generic generic-write) (init-generic generic-prin) (init-generic output) (init-generic generic-read) (init-generic flush) (init-generic binary+) (init-generic binary-) (init-generic binary*) (init-generic binary/) (init-generic binary-gcd) (init-generic binary-lcm) (init-generic binary<) (init-generic negate) (init-generic equal) (simple-add-method add-method (simple-make-method (quote signature) (list <generic-function> <method>) (quote function) add-method-method)) (simple-add-method = (simple-make-method (quote signature) (list <fixint> <fixint>) (quote function) binary=_Integer)) (add-method allocate (simple-make-method (quote signature) (list <class> <object>) (quote function) std-allocate-object)) (add-method initialize (simple-make-method (quote signature) (list <object> <object>) (quote function) std-initialize-object)) (add-method initialize (simple-make-method (quote signature) (list <method> <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** a b) ((lambda (new) ((setter method-signature) a (scan-args (quote signature) b required-argument)) (set-type new method-type) new) (if ***method-status-handle*** (progn (call-method-by-list ***method-status-handle*** ***method-args-handle***)) (error "No Next Method" <Internal-Error> nil)))))) (add-method initialize (simple-make-method (quote signature) (list <generic-function> <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** a initargs) ((lambda (new) ((generic-setter generic-slow-cache) new nil) ((generic-setter generic-fast-cache) new nil) ((generic-setter generic-method-table) new nil) (if (eq (generic-argtype new) unbound-slot-value) ((setter generic-argtype) new (list-length (scan-args (quote lambda-list) initargs required-argument))) nil) ((lambda (domain) ((lambda (lookup-fn methods method-class) ((setter generic-method-lookup-function) new lookup-fn) ((lambda (disc-fun disc-methods) ((setter generic-discriminator) new disc-fun) (if (eq (car disc-methods) std-discrimination-method) (set-type new generic-type) nil)) (compute-discriminating-function new domain lookup-fn methods) (find-applicable-methods compute-discriminating-function (list new domain lookup-fn methods))) (set-generic-method-description new method-class domain) ((generic-setter generic-discrimination-depth) new 0) (mapc1 (lambda (meth) (add-method new meth)) methods)) (compute-method-lookup-function new domain) (scan-args (quote methods) initargs null-argument) (scan-args (quote method-class) initargs (default-argument <method>)))) (scan-args (quote domain) initargs null-argument)) new) (if ***method-status-handle*** (progn (call-method-by-list ***method-status-handle*** ***method-args-handle***)) (error "No Next Method" <Internal-Error> nil)))))) (add-method compute-method-lookup-function (simple-make-method (quote signature) (list <generic-function> <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** gf domain) (lambda (args) (find-applicable-methods gf args))))) (defconstant std-discrimination-method (simple-make-method (quote signature) (list <generic-function> <object> <object> <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** gf dom lookup meths) (lambda (args) ((lambda (meths) (if (null meths) (error "No applicable method" no-applicable-method (quote error-value) gf (quote sig) (mapcar1 class-of args)) (call-method-by-list meths args))) (lookup args)))))) (add-method compute-discriminating-function std-discrimination-method) (add-method generic-prin (make <method> (quote signature) (list <object> <object>) (quote function) prin-object)) (add-method generic-write (make <method> (quote signature) (list <object> <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** x y) (generic-prin x y)))) (add-method flush (make <method> (quote signature) (list <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** y) nil))) (deflocal no-applicable-method ()) (defun set-no-applicable-method (x) (setq no-applicable-method x)) (export set-no-applicable-method) (add-method allocate (make <method> (quote signature) (list <primitive-class> <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** c l) (error "Cannot allocate primitive class" <Internal-Error> (quote error-value) c)))) (defconstant copy (make <generic-function> (quote lambda-list) (quote (x)) (quote argtype) 1 (quote name) (quote copy) (quote method-class) <method>)) (add-method copy (make <method> (quote signature) (list <pair>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** x) (cons (car x) (cdr x))))) (add-method copy (make <method> (quote signature) (list (class-of nil)) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** x) nil))) (add-method copy (make <method> (quote signature) (list <structure>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** x) ((lambda (copy-slots) (setq copy-slots (lambda (old new slot-list) (if (null slot-list) nil (progn ((slot-description-slot-writer (car slot-list)) new ((slot-description-slot-reader (car slot-list)) new)) (copy-slots old new (cdr slot-list)))))) (copy-slots x (allocate (class-of x) nil) (class-slot-descriptions x))) ())))) (add-method copy (make <method> (quote signature) (list <symbol>) (quote function) identity)) (add-method copy (make <method> (quote signature) (list <vector>) (quote function) |generic_copy,Vector|)) (export copy) (defconstant generic-hash (make <generic-function> (quote lambda-list) (quote (x)) (quote argtype) 1 (quote name) (quote generic-hash) (quote method-class) <method>)) (add-method generic-hash (make <method> (quote signature) (list <i-function>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** x) 99))) (add-method generic-hash (make <method> (quote signature) (list <object>) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** x) 0))) (set-standard-tab-functions generic-hash eq) (export generic-hash) (defconstant i-function-setters (make-table ())) (defconstant i-setter (lambda (***method-status-handle*** ***method-args-handle*** x) ((lambda (xx) (if (functionp xx) xx (error "Setter: no setter for function" <Internal-Error> (quote error-value) x))) (sys-table-ref i-function-setters x)))) (defconstant i-setter-setter (lambda (***method-status-handle*** ***method-args-handle*** x y) (if (if (functionp x) (if (functionp y) t nil) nil) ((setter sys-table-ref) i-function-setters x y) (error "Bad setter" <Internal-Error> (quote error-value) (cons x y))))) (add-method setter (make <method> (quote signature) (list <i-function>) (quote function) i-setter)) (add-method setter (make <method> (quote signature) (list <c-function>) (quote function) c-setter)) (add-method setter-setter (make <method> (quote signature) (list <i-function> <object>) (quote function) i-setter-setter)) (add-method setter-setter (make <method> (quote signature) (list <c-function> <object>) (quote function) c-setter-setter)) (setter-setter setter setter-setter) (defconstant error (lambda (message type . junk) ((lambda (lst) (internal-signal (initialize (allocate type lst) lst) nil)) (cons (quote message) (cons message junk))))) (defconstant cerror (lambda (message type . junk) ((lambda (lst) (simple-call/cc (lambda (cont) (internal-signal (initialize (allocate type lst) lst) cont)))) (cons (quote message) (cons message junk))))) (export error cerror) (add-method binary+ (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary+_Integer)) (add-method binary- (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary-_Integer)) (add-method binary* (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary*_Integer)) (add-method binary/ (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary/_Integer)) (add-method binary-lcm (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary-lcm-integer)) (add-method binary-gcd (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary-gcd-integer)) (add-method binary< (make <method> (quote signature) (list <fixint> <fixint>) (quote function) binary<_Integer)) (add-method negate (make <method> (quote signature) (list <fixint>) (quote function) negate-integer)) ) 
